home *** CD-ROM | disk | FTP | other *** search
/ Internet Tools (InfoMagic) / Internet Tools.iso / archival / mirror / experimental / lchat.pl.Z / lchat.pl
Perl Script  |  1994-11-24  |  6KB  |  242 lines
  1. # This is little chat.  It is based on the chat2 that I did for mirror
  2. # which in turn was based on the Randal Schwartz version.
  3. #   This version can only have one outgoing open at a time.  This
  4. # avoids returning string filehandles which were a source of memory leaks.
  5. #
  6. # chat.pl: chat with a server
  7. # Based on: V2.01.alpha.7 91/06/16
  8. # Randal L. Schwartz (was <merlyn@iwarp.intel.com>)
  9. # multihome additions by A.Macpherson@bnr.co.uk
  10. # allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
  11. # $Id: chat2.pl,v 2.3 1994/02/03 13:45:35 lmjm Exp lmjm $
  12. # $Log: chat2.pl,v $
  13. # Revision 2.3  1994/02/03  13:45:35  lmjm
  14. # Correct chat'read (bfriesen@simple.sat.tx.us)
  15. #
  16. # Revision 2.2  1993/12/14  11:09:03  lmjm
  17. # Only include sys/socket.ph if not already there.
  18. # Allow for system 5.
  19. #
  20. # Revision 2.1  1993/06/28  15:11:07  lmjm
  21. # Full 2.1 release
  22. #
  23.  
  24. package chat;
  25.  
  26. unless( defined &'PF_INET ){
  27.     eval "sub ATT { 0; } sub INTEL { 0; }";
  28.     do 'sys/socket.ph';
  29. }
  30.  
  31.  
  32. if( defined( &main'PF_INET ) ){
  33.     $pf_inet = &main'PF_INET;
  34.     $sock_stream = &main'SOCK_STREAM;
  35.     local($name, $aliases, $proto) = getprotobyname( 'tcp' );
  36.     $tcp_proto = $proto;
  37. }
  38. else {
  39.     # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
  40.     # but who the heck would change these anyway? (:-)
  41.     $pf_inet = 2;
  42.     $sock_stream = 1;
  43.     $tcp_proto = 6;
  44. }
  45.  
  46.  
  47. $sockaddr = 'S n a4 x8';
  48. chop( $thishost = `(hostname || uname -n || uuname -l) 2>/dev/null` );
  49.  
  50.  
  51. ## &chat'open_port("server.address",$port_number);
  52. ## opens a named or numbered TCP server
  53.  
  54. sub open_port { ## public
  55.     local($server, $port) = @_;
  56.  
  57.     local($serveraddr,$serverproc);
  58.  
  59.     # We may be multi-homed, start with 0, fixup once connexion is made
  60.     $thisaddr = "\0\0\0\0" ;
  61.     $thisproc = pack($sockaddr, 2, 0, $thisaddr);
  62.  
  63.     if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
  64.         $serveraddr = pack('C4', $1, $2, $3, $4);
  65.     } else {
  66.         local(@x) = gethostbyname($server);
  67.         if( ! @x ){
  68.             return undef;
  69.         }
  70.         $serveraddr = $x[4];
  71.     }
  72.     $serverproc = pack($sockaddr, 2, $port, $serveraddr);
  73.     unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
  74.         ($!) = ($!, close(S)); # close S while saving $!
  75.         return undef;
  76.     }
  77.     unless (bind(S, $thisproc)) {
  78.         ($!) = ($!, close(S)); # close S while saving $!
  79.         return undef;
  80.     }
  81.     unless (connect(S, $serverproc)) {
  82.         ($!) = ($!, close(S)); # close S while saving $!
  83.         return undef;
  84.     }
  85. # We opened with the local address set to ANY, at this stage we know
  86. # which interface we are using.  This is critical if our machine is
  87. # multi-homed, with IP forwarding off, so fix-up.
  88.     local($fam,$lport);
  89.     ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
  90.     $thisproc = pack($sockaddr, 2, 0, $thisaddr);
  91. # end of post-connect fixup
  92.     select((select(S), $| = 1)[0]);
  93.     return 1;
  94. }
  95.  
  96. ## $return = &chat'expect($timeout_time,
  97. ##     $pat1, $body1, $pat2, $body2, ... )
  98. ## $timeout_time is the time (either relative to the current time, or
  99. ## absolute, ala time(2)) at which a timeout event occurs.
  100. ## $pat1, $pat2, and so on are regexs which are matched against the input
  101. ## stream.  If a match is found, the entire matched string is consumed,
  102. ## and the corresponding body eval string is evaled.
  103. ##
  104. ## Each pat is a regular-expression (probably enclosed in single-quotes
  105. ## in the invocation).  ^ and $ will work, respecting the current value of $*.
  106. ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
  107. ## If pat is 'EOF', the body is executed if the process exits before
  108. ## the other patterns are seen.
  109. ##
  110. ## Pats are scanned in the order given, so later pats can contain
  111. ## general defaults that won't be examined unless the earlier pats
  112. ## have failed.
  113. ##
  114. ## The result of eval'ing body is returned as the result of
  115. ## the invocation.  Recursive invocations are not thought
  116. ## through, and may work only accidentally. :-)
  117. ##
  118. ## undef is returned if either a timeout or an eof occurs and no
  119. ## corresponding body has been defined.
  120. ## I/O errors of any sort are treated as eof.
  121.  
  122. $nextsubname = "expectloop000000"; # used for subroutines
  123.  
  124. sub expect { ## public
  125.     local($endtime) = shift;
  126.  
  127.     local($timeout,$eof) = (1,1);
  128.     local($caller) = caller;
  129.     local($rmask, $nfound, $timeleft, $thisbuf);
  130.     local($cases, $pattern, $action, $subname);
  131.     $endtime += time if $endtime < 600_000_000;
  132.  
  133.     # now see whether we need to create a new sub:
  134.  
  135.     unless ($subname = $expect_subname{$caller,@_}) {
  136.         # nope.  make a new one:
  137.         $expect_subname{$caller,@_} = $subname = $nextsubname++;
  138.  
  139.         $cases .= <<"EDQ"; # header is funny to make everything elsif's
  140. sub $subname {
  141.     LOOP: {
  142.         if (0) { ; }
  143. EDQ
  144.         while (@_) {
  145.             ($pattern,$action) = splice(@_,0,2);
  146.             if ($pattern =~ /^eof$/i) {
  147.                 $cases .= <<"EDQ";
  148.         elsif (\$eof) {
  149.              package $caller;
  150.             $action;
  151.         }
  152. EDQ
  153.                 $eof = 0;
  154.             } elsif ($pattern =~ /^timeout$/i) {
  155.             $cases .= <<"EDQ";
  156.         elsif (\$timeout) {
  157.              package $caller;
  158.             $action;
  159.         }
  160. EDQ
  161.                 $timeout = 0;
  162.             } else {
  163.                 $pattern =~ s#/#\\/#g;
  164.             $cases .= <<"EDQ";
  165.         elsif (\$S =~ /$pattern/) {
  166.             \$S = \$';
  167.              package $caller;
  168.             $action;
  169.         }
  170. EDQ
  171.             }
  172.         }
  173.         $cases .= <<"EDQ" if $eof;
  174.         elsif (\$eof) {
  175.             undef;
  176.         }
  177. EDQ
  178.         $cases .= <<"EDQ" if $timeout;
  179.         elsif (\$timeout) {
  180.             undef;
  181.         }
  182. EDQ
  183.         $cases .= <<'ESQ';
  184.         else {
  185.             $rmask = "";
  186.             vec($rmask,fileno(S),1) = 1;
  187.             ($nfound, $rmask) =
  188.                  select($rmask, undef, undef, $endtime - time);
  189.             if ($nfound) {
  190.                 $nread = sysread(S, $thisbuf, 1024);
  191.                 if( $chat'debug ){
  192.                     print STDERR "sysread $nread ";
  193.                     print STDERR ">>$thisbuf<<\n";
  194.                 }
  195.                 if ($nread > 0) {
  196.                     $S .= $thisbuf;
  197.                 } else {
  198.                     $eof++, redo LOOP; # any error is also eof
  199.                 }
  200.             } else {
  201.                 $timeout++, redo LOOP; # timeout
  202.             }
  203.             redo LOOP;
  204.         }
  205.     }
  206. }
  207. ESQ
  208.         eval $cases; die "$cases:\n$@" if $@;
  209.     }
  210.     $eof = $timeout = 0;
  211.     do $subname();
  212. }
  213.  
  214. ## &chat'print(@data)
  215. sub print { ## public
  216.     print S @_;
  217.     if( $chat'debug ){
  218.         print STDERR "printed:";
  219.         print STDERR @_;
  220.     }
  221. }
  222.  
  223. ## &chat'close()
  224. sub close { ## public
  225.     close(S);
  226. }
  227.  
  228. # &chat'read(*buf, $ntoread )
  229. # blocking read. returns no. of bytes read and puts data in $buf.
  230. # If called with ntoread < 0 then just do the accept and return 0.
  231. sub read { ## public
  232.     local(*chatreadbuf) = shift;
  233.     $chatreadn = shift;
  234.     
  235.     if( $chatreadn > 0 ){
  236.         return sysread(S, $chatreadbuf, $chatreadn );
  237.     }
  238. }
  239.  
  240.  
  241. 1;
  242.